home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / x11 / x-mouse.el.z / x-mouse.el
Encoding:
Text File  |  1998-05-21  |  5.9 KB  |  167 lines
  1. ;; Mouse support for X window system.
  2. ;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1995, 1996 Ben Wing.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  19. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22. ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
  23. ;; This is reserved for use by Hyperbole.
  24. ;;(define-key global-map '(shift button2) 'x-mouse-kill)
  25. (define-key global-map '(control button2) 'x-set-point-and-move-selection)
  26.  
  27. (defun x-mouse-kill (event)
  28.   "Kill the text between the point and mouse and copy it to the clipboard and
  29. to the cut buffer"
  30.   (interactive "@e")
  31.   (let ((old-point (point)))
  32.     (mouse-set-point event)
  33.     (let ((s (buffer-substring old-point (point))))
  34.       (x-own-clipboard s)
  35.       (x-store-cutbuffer s))
  36.     (kill-region old-point (point))))
  37.  
  38. (defun x-yank-function ()
  39.   "Insert the current X selection or, if there is none, insert the X cutbuffer.
  40. A mark is pushed, so that the inserted text lies between point and mark."
  41.   (push-mark)
  42.   (if (region-active-p)
  43.       (if (consp zmacs-region-extent)
  44.       ;; pirated code from insert-rectangle in rect.el
  45.       ;; perhaps that code should be modified to handle a list of extents
  46.       ;; as the rectangle to be inserted?
  47.       (let ((lines zmacs-region-extent)
  48.         (insertcolumn (current-column))
  49.         (first t))
  50.         (push-mark)
  51.         (while lines
  52.           (or first
  53.           (progn
  54.             (forward-line 1)
  55.             (or (bolp) (insert ?\n))
  56.             (move-to-column insertcolumn t)))
  57.           (setq first nil)
  58.           (insert (extent-string (car lines)))
  59.           (setq lines (cdr lines))))
  60.     (insert (extent-string zmacs-region-extent)))
  61.     (x-insert-selection t)))
  62.  
  63. (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
  64.   "Insert the current selection into buffer at point."
  65.   (interactive "P")
  66.   (let ((text (if check-cutbuffer-p
  67.           (or (condition-case () (x-get-selection) (error ()))
  68.               (x-get-cutbuffer)
  69.               (error "No selection or cut buffer available"))
  70.         (x-get-selection))))
  71.     (cond (move-point-event
  72.        (mouse-set-point move-point-event)
  73.        (push-mark (point)))
  74.       ((interactive-p)
  75.        (push-mark (point))))
  76.     (insert text)
  77.     ))
  78.  
  79. (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
  80. (defun x-set-point-and-insert-selection (event)
  81.   "Set point where clicked and insert the primary selection or the cut buffer."
  82.   (interactive "e")
  83.   (let ((mouse-yank-at-point nil))
  84.     (mouse-yank event)))
  85.  
  86. (defun x-set-point-and-move-selection (event)
  87.   "Set point where clicked and move the selected text to that location."
  88.   (interactive "e")
  89.   ;; Don't try to move the selection if x-kill-primary-selection if going
  90.   ;; to fail; just let the appropriate error message get issued. (We need
  91.   ;; to insert the selection and set point first, or the selection may
  92.   ;; get inserted at the wrong place.)
  93.   (and (x-selection-owner-p)
  94.        primary-selection-extent
  95.        (x-insert-selection t event))
  96.   (x-kill-primary-selection))
  97.  
  98. (defun mouse-track-and-copy-to-cutbuffer (event)
  99.   "Make a selection like `mouse-track', but also copy it to the cutbuffer."
  100.   (interactive "e")
  101.   (mouse-track event)
  102.   (cond
  103.    ((null primary-selection-extent)
  104.     nil)
  105.    ((consp primary-selection-extent)
  106.     (save-excursion
  107.       (set-buffer (extent-object (car primary-selection-extent)))
  108.       (x-store-cutbuffer
  109.        (mapconcat
  110.     'identity
  111.     (extract-rectangle
  112.      (extent-start-position (car primary-selection-extent))
  113.      (extent-end-position (car (reverse primary-selection-extent))))
  114.     "\n"))))
  115.    (t
  116.     (save-excursion
  117.       (set-buffer (extent-object primary-selection-extent))
  118.       (x-store-cutbuffer
  119.        (buffer-substring (extent-start-position primary-selection-extent)
  120.              (extent-end-position primary-selection-extent)))))))
  121.  
  122.  
  123. (defvar x-pointers-initialized nil)
  124.  
  125. (defun x-init-pointer-shape (device)
  126.   "Initializes the mouse-pointers of the given device from the resource
  127. database."
  128.   (if x-pointers-initialized  ; only do it when the first device is created
  129.       nil
  130.     (set-glyph-image text-pointer-glyph
  131.       (or (x-get-resource "textPointer" "Cursor" 'string device)
  132.           "xterm"))
  133.     (set-glyph-image selection-pointer-glyph
  134.       (or (x-get-resource "selectionPointer" "Cursor" 'string device)
  135.           "top_left_arrow"))
  136.     (set-glyph-image nontext-pointer-glyph
  137.       (or (x-get-resource "spacePointer" "Cursor" 'string device)
  138.           "xterm")) ; was "crosshair"
  139.     (set-glyph-image modeline-pointer-glyph
  140.       (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
  141.           "sb_v_double_arrow"))
  142.     (set-glyph-image gc-pointer-glyph
  143.       (or (x-get-resource "gcPointer" "Cursor" 'string device)
  144.           "watch"))
  145.     (when (featurep 'scrollbar)
  146.       (set-glyph-image
  147.        scrollbar-pointer-glyph
  148.        (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
  149.        "top_left_arrow")))
  150.     (set-glyph-image busy-pointer-glyph
  151.       (or (x-get-resource "busyPointer" "Cursor" 'string device)
  152.           "watch"))
  153.     (set-glyph-image toolbar-pointer-glyph
  154.       (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
  155.           "left_ptr"))
  156.     (let ((fg
  157.        (x-get-resource "pointerColor" "Foreground" 'string device)))
  158.       (and fg
  159.        (set-face-foreground 'pointer fg)))
  160.     (let ((bg
  161.        (x-get-resource "pointerBackground" "Background" 'string device)))
  162.       (and bg
  163.        (set-face-background 'pointer bg)))
  164.     (setq x-pointers-initialized t))
  165.   nil)
  166.  
  167.